home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / miscpas.zip / PLOTFUNC.PAS < prev    next >
Pascal/Delphi Source File  |  1984-06-12  |  3KB  |  129 lines
  1. program func;
  2.  
  3. {   3d hidden line plot routine by Jim Reider, Atlanta, Ga.     }
  4.  
  5. {   This program plots two functions on the hires screen.  The  }
  6. {   plotting functions have hidden line features.               }
  7.  
  8. {   The program uses two external procedures.  You must have    }
  9. {   POINT.INV and LINE.INV on the default disk drive in order   }
  10. {   to compile this program.                                    }
  11.  
  12. {   Translated into TurboPascal by Jeff Firestone.  June, 1984  }
  13.  
  14. type
  15.   PassNum = (First, Second);
  16. var
  17.   x1,y1,bs,b1,b2,a,k,g,r,x2,y2,r2,m1,q1,q2,gr,k1,k3,k4 : real;
  18.   v1,s1,hm,h,v,rc,x,y,z,rr : real;
  19.   NewX, NewY, OldX, OldY, q, z1, k2 : integer;
  20.   hh : array [0..150] of integer;
  21.   f, OkTest : boolean;
  22.   Pass : PassNum;
  23.  
  24. procedure dot (a,b,c    :integer); external 'point.inv';
  25. procedure line(a,b,c,d,e:integer); external 'line.inv';
  26.  
  27. procedure Init;
  28. begin
  29.   FillChar(hh, sizeof(hh), 0);
  30.   X1:= 0; Y1:= 0; OldX:= 0; OldY:= 0;
  31.   BS:= 0.01; k:=0; g:=0; r:=0; a:=0;
  32.   B1:= 1 - ((2 * LN(1)) / (LN(1) - LN(BS)));
  33.   B2:= 2 / (LN(1) - LN(BS));
  34.   write('WHICH FUNCTION (0 OR 1) ');  read(A); writeln;
  35.   write('RANGE (Default:= 2) ');  read(k);  IF K = 0 THEN K:= 2;  writeln;
  36.   write('GRID (Default:= 16) ');  read(g);  IF G = 0 THEN G:= 16; writeln;
  37.   write('RESOL (Default:= 2) ');  read(r);  IF R = 0 THEN R:= 2;  writeln;
  38.   X2:= K * PI;
  39.   Y2:= K * PI;
  40.   R2:= 2*R; M1:= G*R2; Q1:= M1-R; Q2:= M1+R; GR:= G*R;
  41.   K1:= 300 / M1;
  42.   K2:= 96;
  43.   K3:= 96 / (SQRT(3) * M1);
  44.   K4:= 48 / SQRT(3);
  45.   Hires; HiresColor(7);
  46. end;
  47.  
  48. begin
  49.   Init;
  50.   Pass:= First;
  51.   v1:= -q1;
  52.   repeat
  53.     S1:= -(V1 / abs(v1));
  54.     HM:= Q2 - ABS(V1);
  55.     H:= -HM;
  56.     V:= V1 + (R * S1);
  57.     F:= False;
  58.     rc:= r;
  59.  
  60.     repeat
  61.     if (rc <= 0) and (Pass = Second) then
  62.     begin
  63.       S1:= -S1;
  64.       RC:= R;
  65.     end;
  66.  
  67.     Pass:= Second;
  68.     X:= X1 + (V + H) * (X2 / M1);
  69.     Y:= Y1 + (V - H) * (Y2 / M1);
  70.     if (a = 0) then
  71.     begin
  72.       Z:= 1;
  73.       IF (X <> 0) THEN Z:= SIN(X) / X;
  74.       IF (Y <> 0) THEN Z:= Z * SIN(Y) / Y;
  75.       Z:= ABS(Z);
  76.     end;
  77.  
  78.     if (a <> 0) then
  79.     begin
  80.       RR:= SQRT((X * X) + (Y * Y));
  81.       IF (RR = 0)  THEN Z:= 1;
  82.       IF (RR > X2) THEN Z:= -1;
  83.       if not((rr = 0) or (rr > x2)) then Z:= ABS(SIN(RR) / RR);
  84.     end;
  85.  
  86.     if (a = 0) or not((rr = 0) or (rr > x2)) then
  87.     begin
  88.       IF (Z < BS) THEN
  89.           Z:= -1
  90.       ELSE
  91.           Z:= B1 + (B2 * LN(Z))
  92.     end;
  93.  
  94.     Z1:= K2 + round((V * K3) + (Z * K4));
  95.     Q:= trunc(GR + (H / 2));
  96.     OkTest:= True;
  97.     IF (Z1 >= HH[Q]) THEN
  98.     BEGIN
  99.         OkTest:= False;
  100.         HH[Q]:= Z1;
  101.         Z1:= 200 - Z1;
  102.         IF (F = true) THEN
  103.         begin
  104.           NewX:= 320+round(h * k1);
  105.           line (OldX, OldY, NewX, Z1, 1);
  106.           OldX:= NewX; OldY:= Z1;
  107.         end;
  108.         if (f = false) then
  109.         begin
  110.           NewX:= 320+round(H * K1);
  111.           dot (NewX, Z1, 1);
  112.           OldX:= NewX; OldY:= Z1;
  113.           F:= true;
  114.         end;
  115.     END;
  116.  
  117.     if OkTest then F:= false;
  118.  
  119.     if (h <> hm) then
  120.     begin
  121.       V:= V - (2 * S1);
  122.       H:= H + 2;
  123.       RC:= RC - 1;
  124.     end;
  125.     until (h = hm);
  126.  
  127.     v1:= v1 + r2;
  128.   until (v1 >= q1);
  129. end.